      SUBROUTINE SETUP
      RETURN
      END
C   HS70
      SUBROUTINE EF(X,FX)
      INCLUDE 'FUCO.INC'
      INTEGER I
      DOUBLE PRECISION D,C,CL,Y
      COMMON /DAT/ D(19),C(19),CL(19),Y(19)
      DOUBLE PRECISION  X(NX),FX,S,X1,X2,X3,X4,
     F   BET,W1,W2,BETX4,DLX4,DLBET,FAC1,FAC2,YIC,E1,E2,CL1,CL2
      ICF=ICF+1
      S=0.D0
      IF(ICF .NE. 1)      GOTO 50
      CALL SETDAT
   50 CONTINUE
      X1=X(1)
      X2=X(2)
      X3=X(3)
      X4=X(4)
      BET=X3+(1.D0-X3)*X4
      W1 =DSQRT(DABS(X1))
      W2 =DSQRT(DABS(X2))
      BETX4=0.D0
      DLX4=0.D0
      DLBET=0.D0
      IF(BET .LE. 0.D0 .OR. X4 .LE. 0.D0)      GOTO 100
      DLBET=DLOG(BET)
      BETX4=BET/X4
      DLX4=DLOG(X4)
  100 CONTINUE
      FAC1=W2*X2*X3/(1.D0+12.D0*X2)
      FAC2=W1*X1*(1.D0-X3)/(1.D0+12.D0*X1)
      DO      200      I=1,19
      YIC=0.D0
      IF(BET .LE. 0.D0 .OR. X4 .LE. 0.D0)      GOTO 150
      E1=0.D0
      CL1=X2*(1.D0-C(I)*BET  +DLBET     +CL(I))
      IF(CL1 .GE. -170.D0)   E1=DEXP(CL1)
      E2=0.D0
      CL2=X1*(1.D0-C(I)*BETX4+DLBET-DLX4+CL(I))
      IF(CL2 .GE. -170.D0)   E2=DEXP(CL2)
      YIC=D(I)*(FAC1*E1+FAC2*E2)
  150 CONTINUE
      S=S+(YIC-Y(I))**2
  200 CONTINUE
      FX=S
      RETURN
      END
      SUBROUTINE EGRADF(X,GRADF)
      INCLUDE 'FUCO.INC'
      INTEGER I
      DOUBLE PRECISION D,C,CL,Y
      COMMON /DAT/ D(19),C(19),CL(19),Y(19)
      DOUBLE PRECISION X(NX),GRADF(NX)
      DOUBLE PRECISION X1,X2,X3,X4,BET,W1,W2,BETINV,DLX4,DLBET,
     F  F11,F12,F13,F21,F22,F23,F31,F32,F33,F34,FAC2,FAC1,YIC,
     F  E1,E2,CL1,CL2,BETX4,H1,H2,H3,F41,F42
      ICGF=ICGF+1
      X1=X(1)
      X2=X(2)
      X3=X(3)
      X4=X(4)
      DO      100      I=1,4
      GRADF(I)=0.D0
  100 CONTINUE
      BET=X3+(1.D0-X3)*X4
      W1 =DSQRT(DABS(X1))
      W2 =DSQRT(DABS(X2))
      IF(BET .LE. 0.D0 .OR. X4 .LE. 0.D0)    RETURN
      BETINV=1.D0/BET
      BETX4=BET/X4
      DLX4=DLOG(X4)
      DLBET=DLOG(BET)
      F11=W1*(1.D0-X3)/(1.D0+12.D0*X1)**2
      F12=X1*(1.D0+12.D0*X1)
      F13=1.5D0+6.D0*X1
      F21=W2*X3/(1.D0+12.D0*X2)**2
      F22=X2*(1.D0+12.D0*X2)
      F23=1.5D0+6.D0*X2
      F31=W1*X1/(1.D0+12.D0*X1)
      FAC2=F31*(1.D0-X3)
      F32=X1*(1.D0-X3)*(1.D0-X4)
      F33=W2*X2/(1.D0+12.D0*X2)
      FAC1=F33*X3
      F34=X3*X2*(1.D0-X4)
      F41=F33*X2*X3*(1.D0-X3)
      F42=F31*X1*X3*(1.D0-X3)
      DO      400      I=1,19
      YIC=0.D0
      E1=0.D0
      CL1=1.D0-C(I)*BET+DLBET+CL(I)
      IF(X2*CL1 .GE. -170.D0)   E1=DEXP(CL1*X2)
      E2=0.D0
      CL2=1.D0-C(I)*BETX4+DLBET-DLX4+  CL(I)
      IF(X1*CL2 .GE. -170.D0)   E2=DEXP(CL2*X1)
      YIC=D(I)*(FAC1*E1+FAC2*E2)
      YIC=2.D0*(YIC-Y(I))
      GRADF(1)=GRADF(1)+YIC*D(I)*E2*F11*(CL2*F12+F13)
      GRADF(2)=GRADF(2)+YIC*D(I)*E1*F21*(CL1*F22+F23)
      H1=BETINV-C(I)
      H2=BETINV-C(I)/X4
      H3=H2/X4
      GRADF(3)=GRADF(3)+YIC*D(I)*(E1*F33*(1.D0+F34*H1)
     1                  +E2*F31*(-1.D0+F32*H2))
      GRADF(4)=GRADF(4)+YIC*D(I)*(F41*E1*H1-F42*E2*H3)
  400 CONTINUE
      RETURN
      END
      SUBROUTINE EH(I,X,HXI)
      INCLUDE 'FUCO.INC'
      INTEGER I
      DOUBLE PRECISION X(NX),HXI
      CRES(I)=CRES(I)+1
      RETURN
      END
      SUBROUTINE EGRADH(I,X,GRADHI)
      INCLUDE 'FUCO.INC'
      INTEGER I
      DOUBLE PRECISION X(NX),GRADHI(NX)
      CGRES(I)=CGRES(I)+1
      RETURN
      END
      SUBROUTINE EG(I,X,GXI)
      INCLUDE 'FUCO.INC'
      INTEGER I
      DOUBLE PRECISION X(NX),UG(4),OG(4),GXI
      SAVE UG,OG
      DATA UG/4*1.D-5/, OG/2*1.D2,1.D0,1.D2/
      IF ( GUNIT(1,I+NH) .EQ. -1 )CRES(I+NH)=CRES(I+NH)+1      
      GOTO(100,200,200,200,200,300,300,300,300),I
  100 CONTINUE
      GXI= X(3)+(1.D0-X(3))*X(4)
      RETURN
  200 CONTINUE
      GXI= X(I-1)-UG(I-1)
      RETURN
  300 CONTINUE
      GXI=OG(I-5)-X(I-5)
      RETURN
      END
      SUBROUTINE EGRADG(I,X,GRADGI)
      INCLUDE 'FUCO.INC'
      INTEGER I,J
      DOUBLE PRECISION X(NX) ,GRADGI(NX)
      IF ( GUNIT(1,I+NH) .EQ. 1 )RETURN
      CGRES(I+NH)=CGRES(I+NH)+1
      DO      10      J=1,4
      GRADGI(J)=0.D0
  10  CONTINUE
      IF(I .GT. 1)          GOTO 100
      GRADGI(3)= 1.D0-X(4)
      GRADGI(4)= 1.D0-X(3)
      RETURN
  100 CONTINUE
      IF(I .GE. 6)      GRADGI(I-5)=-1.D0
      IF(I .LE. 5)      GRADGI(I-1)= 1.D0
      RETURN
      END
      SUBROUTINE SETDAT
      IMPLICIT NONE
      INTEGER I
      DOUBLE PRECISION D,C,CL,Y
      COMMON /DAT/ D(19),C(19),CL(19),Y(19)
      DOUBLE PRECISION Y0(19),H
      SAVE Y0
      DATA Y0/1.89D-3,.1038D0,.268D0,.506D0,.577D0,.604D0,.725D0,.898D0,
     1        .947D0,.845D0,.702D0,.528D0,.385D0,.257D0,.159D0,.869D-1,
     2        .453D-1,.1509D-1,.189D-2/
      C(1)=.1D0/7.658D0
      CL(1)=DLOG(C(1))
      H=12.D0/DSQRT(6.2832D0)
      D(1)=H/C(1)
      Y(1)=Y0(1)
      DO      100      I=2,19
      C(I)=DBLE(REAL(I-1))/7.658D0
      CL(I)=DLOG(C(I))
      D(I)=H/C(I)
      Y(I)=Y0(I)
  100 CONTINUE
      RETURN
      END
      BLOCK DATA
      INCLUDE 'BLOCO.INC'
      INTEGER I,J
      DATA NAME/'HS70'/
      DATA (X(I),I=1,4)/2.D0,4.0D0,4.0D-2,2.D0/
      DATA N/4/ , NH/0/ , NG/ 9/
C NEW X2*12+1>0 !
      DATA DEL0/1.D0/ ,TAU0/1.D0/ ,TAU/.1D0/
      DATA ((GUNIT(I,J),I=1,3),J=0,9)/-1,0,0,-1,0,0,
     F           1,1,1,1,2,1,1,3,1,1,4,1,
     F           1,1,-1,1,2,-1,1,3,-1,1,4,-1/
      END
